/*****************************************************************************/
/*      (c) Copyright 2006 Rapid Deployment Software - See License.txt       */
/*****************************************************************************/
/*                                                                           */
/*                         BACKEND STORAGE ALLOCATION                        */
/*                                                                           */
/*****************************************************************************/

/*
 * On Windows we use the WIN32 Heap functions on the default heap.
 * This lets us share the heap with any Euphoria .dlls. We serialize access
 * to this heap because of the warnings given in the WIN32 docs.
 * The internal representation of a Euphoria object requires blocks that
 * are 8-byte aligned. We can deal with 4-byte aligned blocks from malloc
 * on all systems, but we will only see 8-byte aligned blocks on Windows
 * (except Windows 95), and FreeBSD. A storage "cache" is used to cut down
 * on the number of calls to malloc. On FreeBSD we do not use the
 * storage cache because it's not easy to determine the block size
 * of freed blocks.
 */

/******************/
/* Included files */
/******************/
#include <stdio.h>

#ifdef EWINDOWS
# include <windows.h>
#elif ELINUX
# include <unistd.h>
#endif

#include "global.h"
#include "execute.h"
#include "symtab.h"
#include "alloc.h"

/******************/
/* Local defines  */
/******************/

#define NUMBER_OF_SIZES 14      /* number of size lists in pool */
#define RESOLUTION 8            /* minimum size & increment before mapping */
#define LOG_RESOLUTION 3        /* log2 of RESOLUTION */
#define STR_CHUNK_SIZE 4096     /* chars */
#define SYM_CHUNK_SIZE 50       /* entries */
#define TMP_CHUNK_SIZE 50       /* entries */

/**********************/
/* Imported variables */
/**********************/

#ifdef EWINDOWS
extern unsigned default_heap;
#endif

/**********************/
/* Exported variables */
/**********************/

#ifdef ELINUX
int pagesize;  // needed for Linux only, not FreeBSD
#endif

int align4 = 0;

s1_ptr d_list = NULL;

struct block_list *pool_map[MAX_CACHED_SIZE/RESOLUTION+1];
/* maps size desired to appropriate list */

symtab_ptr call_back_arg1;
symtab_ptr call_back_arg2;
symtab_ptr call_back_arg3;
symtab_ptr call_back_arg4;
symtab_ptr call_back_arg5;
symtab_ptr call_back_arg6;
symtab_ptr call_back_arg7;
symtab_ptr call_back_arg8;
symtab_ptr call_back_arg9;
symtab_ptr call_back_result;

unsigned cache_size = 0;

#ifdef EXTRA_STATS
unsigned recycles = 0;          /* calls to Recycle() */
long a_miss = 0;                /* cache list was empty */
long a_hit = 0;                 /* found in cache */
long a_too_big = 0;             /* too big - no caching */
#endif

#ifdef HEAP_CHECK
long bytes_allocated = 0;       /* current number of object blocks alloc'd */
long max_bytes_allocated = 0;   /* high water mark */
#endif

/*******************/
/* Local variables */
/*******************/

#ifdef EWINDOWS
static struct block_list pool[NUMBER_OF_SIZES]; /* pool of free blocks */
                         /* elements not power of 2 - but not used much */
#endif

/**********************/
/* Declared functions */
/**********************/

char *EMalloc(unsigned long);
char *ERealloc(unsigned char *, unsigned long);

void EFree(unsigned char *);
void de_reference(s1_ptr);
void RTFatal(char *);

#ifndef EWINDOWS
void free();
#endif
#ifdef HEAP_CHECK
static void AlreadyFree();
#endif

/*********************/
/* Defined functions */
/*********************/

#ifdef HEAP_CHECK
void RTInternal(char *msg)
// Internal error
{
    RTFatal(msg);
}

void check_pool()
{
    int i;

    for (i = 0; i < MAX_CACHED_SIZE/RESOLUTION; i++) {
        if (pool_map[i] < pool || pool_map[i] > pool+NUMBER_OF_SIZES-1)
            RTInternal("Corrupt pool_map!");
    }
}
#endif

symtab_ptr tmp_alloc()
/* return pointer to space for a temporary var/literal constant */
{
    return (symtab_ptr)EMalloc(sizeof(struct temp_entry));
}

void InitEMalloc()
/* initialize storage allocator */
{
#ifdef ELINUX
    pagesize = getpagesize();
#else
    int i, j, p;
    pool[0].size = 8;
    pool[0].first = NULL;
    p = RESOLUTION * 2;
    for (i = 1; i < NUMBER_OF_SIZES; i = i + 2) {
        pool[i].size = p;
        pool[i].first = NULL;
        if (i+1 < NUMBER_OF_SIZES) {
            pool[i+1].size = 3 * p / 2;
            pool[i+1].first = NULL;
            p = p * 2;
        }
    }
    j = 0;
    for (i = 0; i <= MAX_CACHED_SIZE / RESOLUTION; i++) {
        if (pool[j].size < i * RESOLUTION)
            j++;
        pool_map[i] = &pool[j];
    }
#endif
    call_back_arg1 = tmp_alloc();
    call_back_arg1->mode = M_TEMP;
    call_back_arg1->obj = NOVALUE;

    call_back_arg2 = tmp_alloc();
    call_back_arg2->mode = M_TEMP;
    call_back_arg2->obj = NOVALUE;

    call_back_arg3 = tmp_alloc();
    call_back_arg3->mode = M_TEMP;
    call_back_arg3->obj = NOVALUE;

    call_back_arg4 = tmp_alloc();
    call_back_arg4->mode = M_TEMP;
    call_back_arg4->obj = NOVALUE;

    call_back_arg5 = tmp_alloc();
    call_back_arg5->mode = M_TEMP;
    call_back_arg5->obj = NOVALUE;

    call_back_arg6 = tmp_alloc();
    call_back_arg6->mode = M_TEMP;
    call_back_arg6->obj = NOVALUE;

    call_back_arg7 = tmp_alloc();
    call_back_arg7->mode = M_TEMP;
    call_back_arg7->obj = NOVALUE;

    call_back_arg8 = tmp_alloc();
    call_back_arg8->mode = M_TEMP;
    call_back_arg8->obj = NOVALUE;

    call_back_arg9 = tmp_alloc();
    call_back_arg9->mode = M_TEMP;
    call_back_arg9->obj = NOVALUE;

    call_back_result = tmp_alloc();
    call_back_result->mode = M_TEMP;
    call_back_result->obj = NOVALUE;
}

#ifdef EXTRA_STATS
void StorageStats()
{
    int i;
    long n;
    free_block_ptr p;
    s1_ptr s;

    s = d_list;
    n = 0;
    while (s != NULL) {
        n++;
        s = (s1_ptr)((free_block_ptr)s)->next;
        if ((long)s % 8 != 0)
            fprintf(stderr, "misaligned s1d pointer!\n");
    }
    printf("\nd_list: %ld   ", n);

    for (i = 0; i < NUMBER_OF_SIZES; i++) {
        printf("%d:", pool[i].size);
        n = 0;
        p = pool[i].first;
        while (p != NULL) {
            n++;
            p = p->next;
        }
        printf("%ld   ", n);
    }
    printf("cache_size: %d\n\n", cache_size);
}
#endif

#ifdef HEAP_CHECK
void Allocated(long n)
/* record that n bytes were allocated */
{
    char buff[80];

    if (n < 0 || n >= 40000000L) {
        sprintf(buff, "bad value passed to Allocated (%d)", n);
        RTInternal(buff);
    }
    bytes_allocated += n;
    if (bytes_allocated > max_bytes_allocated)
        max_bytes_allocated = bytes_allocated;
}

static DeAllocated(long n)
/* record that n bytes were freed */
{
    char buff[100];

    bytes_allocated -= n;
    if (n < 0 || n >= 40000000L)
        RTInternal("bad value passed to DeAllocated");
#ifdef FIX
    if (bytes_allocated < 0 || bytes_allocated >= 140000000L) {
        sprintf(buff, "DeAllocated: bytes_allocated is %d, n is %d\n",
                bytes_allocated, n);
        RTInternal(buff);
    }
#endif
}

void Trash(char *p, long nbytes)
/* write garbage into freed storage block to prevent accidental reuse */
{
    while (nbytes-- > 0)
        *p++ = (char)0x11;
}
#endif // HEAP_CHECK

static void SpaceMessage()
{
    /* should we free up something first, to ensure fprintf's work? */
    RTFatal("Your program has run out of memory.\nOne moment please...");
}

#ifdef EWINDOWS
static void Free_All()
/* free the entire storage cache back to the malloc arena */
{
    int i;
    s1_ptr s;
    struct block_list *list;
    unsigned char *p;

    for (i = 0; i < NUMBER_OF_SIZES; i++) {
        list = &pool[i];
        s = (s1_ptr)list->first;
        while (s != NULL) {
            p = (unsigned char *)s;
            s = (s1_ptr)((free_block_ptr)s)->next;
            if (align4 && *(int *)(p-4) == MAGIC_FILLER)
                p -= 4;
            free(p);
        }
        list->first = NULL;
    }
    /* now do the S1D list */
    s = d_list;
    while (s != NULL) {
        p = (unsigned char *)s;
        s = (s1_ptr)((free_block_ptr)s)->next;
        if (align4 && *(int *)(p-4) == MAGIC_FILLER)
            p = p - 4;
        free(p);
    }
    d_list = NULL;
    cache_size = 0;
}

static void Recycle()
/* Try to recycle some cached blocks back to heap.
   With write-back CPU cache, it might be better
   to free an older block on the list, not the most-recently freed,
   but we only have a singly-linked list */
{
    register struct block_list *list;
    unsigned char *p;
    int i;

#ifdef EXTRA_STATS
    recycles++;
#endif
    /* try to take one from D list */
    if (d_list != NULL) {
        p = (unsigned char *)d_list;
        d_list = (s1_ptr)((free_block_ptr)d_list)->next;
        if (align4 && *(int *)(p-4) == MAGIC_FILLER)
            p = p - 4;
        free(p); /* give it back to malloc arena */
        cache_size -= 1;
    }

    /* try to take one from each other list */
    for (i = 0; i < NUMBER_OF_SIZES; i++) {
        list = &pool[i];
        if (list->first != NULL) {
            p = (unsigned char *)list->first;
            list->first = ((free_block_ptr)p)->next;
            if (align4 && *(int *)(p-4) == MAGIC_FILLER)
                p = p - 4;
            free(p); /* give it back to malloc arena */
            cache_size -= 2;
        }
    }
}

static char *Out_Of_Space(long nbytes)
/* malloc failed - make one last attempt */
{
    long *p;

    Free_All();
    p = (long *)malloc(nbytes);
    if (p == NULL) {
        low_on_space = TRUE;
        SpaceMessage();
        return NULL; /* shouldn't need this */
    }
    else
        return (char *)p;
}
#endif

#ifdef HEAP_CHECK
    char msg[80];
#endif

char *EMalloc(unsigned long nbytes)
/* storage allocator */
/* Always returns a pointer that has 8-byte alignment (essential for our
   internal representation of an object). */
{
#ifdef ELINUX
#ifndef EBSD62
    return malloc(nbytes);
#else
    unsigned char *p;

    p = malloc(nbytes + 8);
    if((unsigned long)p & 7) {
        *(int *)p = MAGIC_FILLER;
        p += 4;
    }
    else {
        *(int *)(p+4) = 0;
        p += 8;
    }
    return p;
#endif
#else
    unsigned char *p, *temp;
    register struct block_list *list;
    int alignment, min_align;

#ifdef HEAP_CHECK
    long size;

    check_pool();
#endif
    nbytes += align4; // allow for possible 4-aligned malloc pointers

    if (nbytes <= MAX_CACHED_SIZE) {
        /* See if we have a block of this size in our cache.
           Every block in the cache is 8-aligned. */

        list = pool_map[(nbytes + (RESOLUTION - 1)) >> LOG_RESOLUTION];
#ifdef HEAP_CHECK
        if (list->size < nbytes || list->size > nbytes * 2) {
            sprintf(msg, "Alloc - size is %d, nbytes is %d", list->size, nbytes);
            RTInternal(msg);
        }
#endif
        temp = (char *)list->first;

        if (temp != NULL) {
            /* a cache hit */

#ifdef EXTRA_STATS
            a_hit++;
#endif
            list->first = ((free_block_ptr)temp)->next;
            cache_size -= 2;

#ifdef HEAP_CHECK
            if (cache_size > 100000000)
                RTInternal("cache size is bad");
            p = temp;
            if (align4 && *(int *)(p-4) == MAGIC_FILLER)
                p = p - 4;
            if (((unsigned long)temp) & 3)
                RTInternal("unaligned address in storage cache");
            Allocated(block_size(p));
#endif
            return temp; /* will be 8-aligned */
        }
        else {
            nbytes = list->size; /* better to grab bigger size
                                    so it can be reused for same purpose */
#ifdef EXTRA_STATS
            a_miss++;
#endif
        }
    }
#ifdef EXTRA_STATS
    else
        a_too_big++;
#endif

    if (cache_size > CACHE_LIMIT)
        // cache is not helping, free some blocks back to general heap
        Recycle();

    do {
        p = malloc(nbytes);

        if (p == NULL)
            p = Out_Of_Space(nbytes);

#ifdef HEAP_CHECK
        Allocated(block_size(p));
#endif
        /* get 8-byte alignment */
        alignment = ((unsigned long)p) & 7;

        if (alignment == 0) {
            if (align4 && *(int *)(p-4) == MAGIC_FILLER)
                // don't free. grab a new one.
                continue;  // magic is there by chance!
                           // (this case is remotely possible on Win95 only)
            return p;   // already 8-aligned, should happen most of the time
        }
        if (alignment != 4)
            RTFatal("malloc block NOT 4-byte aligned!\n");

        if (align4) {
            *(int *)p = MAGIC_FILLER;
            return p+4;
        }

        /* first occurrence of a 4-aligned block */
        free(p);
        align4 = 4;  // start handling 4-aligned blocks
        nbytes += align4;
    } while (TRUE);
#endif
// !ELINUX
}

void EFree(unsigned char *p)
/* free storage pointed to by p. p is an 8-byte aligned pointer */
{
#ifdef HEAP_CHECK
    char msg[80];
#endif

#ifdef ELINUX
#ifndef EBSD62
    free(p);
#else
    if ((int *)(p - 4) == MAGIC_FILLER)
        free(p - 4);
    else
        free(p - 8);
#endif
    return;

#else
    char *q;
    register long nbytes;
    register struct block_list *list;
    int align;
#ifdef HEAP_CHECK
    check_pool();

    if (((long)p & 7) != 0)
        RTInternal("EFree: badly aligned pointer");
#endif
    q = p;
    if (align4 && *(int *)(p-4) == MAGIC_FILLER)
        q -= 4;
    nbytes = block_size(q);
#ifdef HEAP_CHECK
    if ((nbytes & 1) != 0)
        RTInternal("EFree: already free?");
    DeAllocated(nbytes);
    if (nbytes < RESOLUTION || nbytes > 40000000L || (nbytes % 4 != 0)) {
        sprintf(msg, "Free - bad nbytes: %d\n", nbytes);
        RTInternal(msg); /* what if compile time? */
    }
    Trash(p, nbytes - ((char *)p - q));
#endif

    if (nbytes > MAX_CACHED_SIZE || cache_size > CACHE_LIMIT) {
        free(q); /* too big to cache, or cache is full */
    }
    else {
        list = pool_map[nbytes >> LOG_RESOLUTION];
        if (list->size > nbytes) {
            /* only happens with non-standard size (from realloc maybe) */
            list--;
        }
#ifdef HEAP_CHECK
        if (list->size > nbytes)
            RTInternal("Free - list size greater than nbytes");
        if (list->size * 3 / 2 < nbytes - 2)
            RTInternal("Free - list size is small");

        AlreadyFree(list->first, (free_block_ptr)p);  /* can be very slow */
#endif
        ((free_block_ptr)p)->next = list->first;
        list->first = (free_block_ptr)p;
        cache_size += 2;
    }
#endif
}

#ifndef ELINUX
#ifndef ELCC
#ifndef EWINDOWS
#ifdef EXTRA_CHECK
#include <malloc.h>

int heap_dump(char *ptr)
{
    struct _heapinfo h_info;
    int heap_status, found;

    found = FALSE;
    h_info._pentry = NULL;
    for (;;) {
        heap_status = _heapwalk(&h_info);
        if (heap_status != _HEAPOK)
            break;
        //printf("  %s block at %Fp of size %4.4X\n",
        //       (h_info._useflag == _USEDENTRY ? "USED" : "FREE"),
        //       h_info._pentry, h_info._size);
        if ((long)h_info._pentry == (long)(ptr - 4))
            found = TRUE;
    }
    switch (heap_status) {
        case _HEAPEND:
            //printf("OK - end of heap\n");
            break;
        case _HEAPEMPTY:
            //printf("OK - heap is empty\n");
            break;
        case _HEAPBADBEGIN:
            printf("ERROR - heap is damaged\n");
            break;
        case _HEAPBADPTR:
            printf("ERROR - bad pointer to heap\n");
            break;
        case _HEAPBADNODE:
            printf("ERROR - bad node in heap\n");
            break;
    }
    return found;
}
#endif
#endif
#endif
#endif

char *ERealloc(unsigned char *orig, unsigned long newsize)
/* Enlarge or shrink a malloc'd block.
   orig must not be NULL - not supported.
   Return a pointer to a storage area of the desired size
   containing all the original data.
   I don't think a shrink could ever become an expansion + copy
   by accident, but newsize might be less than the current size! */
{
#ifdef ELINUX
#ifndef EBSD62
    // we always have 8-alignment
    return realloc(orig, newsize);  // should do bookkeeping on block size?
#else
    char *p;

    // FreeBSD 6.2 doesn't necessarily give us 8-byte alignment,
    // so we have to make sure it all works out...
    if((int *)(orig - 4) == MAGIC_FILLER) {
        // orig not 8 byte aligned
        p = realloc((orig - 4), newsize + 8);
        if((unsigned long)p & 7 == 0) {
            // the original block wasn't aligned, but this one is, so
            // we need to adjust the memory in order to compensate
            memcpy(p + 8, orig, newsize );
            *(int *)(p + 4) = 0;
            p += 8;
        }
        else
            p += 4;
    }
    else {
        // orig was 8 byte aligned
        p = realloc((orig - 8), newsize + 8);
        if((unsigned long)p & 7 != 0) {
            // the orignal was 8-byte aligned, but the new block isn't
            memcpy(p + 4, orig - 4, newsize + 4);
            p += 4;
        }
        else
            p += 8;
    }
    return p;
#endif
#else
    char *p, *q;
    unsigned long oldsize;

    p = orig;
    if (align4 && *(int *)(p - 4) == MAGIC_FILLER)
        p -= 4;
    oldsize = block_size(p);
    newsize += 8;

    if (newsize <= oldsize) {
        // make a smaller block
        q = realloc(p, newsize);  // no _expand() available
                                  // Borland has it, but it sometimes fails
    }
    else
        q = NULL;

    if (q == NULL)
        /* p only partially expanded, drop through */
    else if (q == p) {
        /* p was successfully expanded in-place */
#ifdef HEAP_CHECK
        if (newsize > oldsize)
            Allocated(block_size(p) - oldsize);
        else
            DeAllocated(oldsize - block_size(p));
#endif
        return orig;
    }
    else if (((long)q & 0x07) == ((long)p & 0x07)) {
        /* q is aligned the same way as p modulo 8 (almost always I think) */
        orig = orig + (q - p);
        return orig;
    }
    else {
        /* q is not aligned right (rare) - get rid of it */
        /* I've never seen this. */
        orig = orig + (q - p);
        p = q;
    }

#ifdef HEAP_CHECK
    Allocated(block_size(p) - oldsize);
#endif
    /* failed to expand in-place, malloc a new space */
    q = EMalloc(newsize);
    /* copy the data to it's new location */
    /* OPTIMIZE? we may be copying more than the actual live data */
    memcpy(q, orig, oldsize - (orig - (unsigned char *)p));
    EFree(orig);
    return q;
#endif
}

#ifdef HEAP_CHECK
static void AlreadyFree(free_block_ptr q, free_block_ptr p)
/* see if p is already on the free list */
{
    while (q != NULL) {
        if (q == p)
            RTInternal("attempt to free again");
        q = q->next;
    }
}

void freeD(unsigned char *p)
/* free double storage block */
{
    long nbytes;
    char *q;
    int alignment;

    q = p;
    if (align4 && *(int *)(p - 4) == MAGIC_FILLER)
        q -= 4;
    nbytes = block_size(q);
    DeAllocated(nbytes);
    if ((long)p % 8 != 0)
        RTInternal("freeS1: misaligned pointer returned");
    if (nbytes < D_SIZE || nbytes > 1024)
        RTInternal("FreeD - bad nbytes ");
    Trash(p, D_SIZE);
    AlreadyFree((free_block_ptr)d_list, (free_block_ptr)p);

    ((d_ptr)p)->dbl = 1e300;  // ->next overlaps with this anyway

    ((free_block_ptr)p)->next = (free_block_ptr)d_list;
    d_list = (s1_ptr)p;
    cache_size += 1;
}
#endif

s1_ptr NewS1(long size)
/* make a new s1 sequence block with a single reference count */
/* size is number of elements, NOVALUE is added as an end marker */
{
    register s1_ptr s1;

    if (size > 1073741800) {
        // multiply by 4 could overflow 32 bits
        SpaceMessage();
    }
    s1 = (s1_ptr)EMalloc(sizeof(struct s1) + (size+1) * sizeof(object));
    s1->ref = 1;
    s1->base = (object_ptr)(s1 + 1);
    s1->length = size;
    s1->postfill = 0; /* there may be some available but don't waste time */
                      /* prepend assumes this is set to 0 */
    s1->base[size] = NOVALUE;
    s1->base--;  // point to "0th" element
    return(s1);
}

object NewString(unsigned char *s)
/* create a new string sequence */
{
    int len;
    object_ptr obj_ptr;
    s1_ptr c1;

    len = strlen((char *)s);
    c1 = NewS1((long)len);
    obj_ptr = (object_ptr)c1->base;
    if (len > 0) {
        do {
            *(++obj_ptr) = (unsigned char)*s++;
        } while (--len > 0);
    }
    return MAKE_SEQ(c1);
}

s1_ptr SequenceCopy(register s1_ptr a)
/* take a single-ref copy of sequence 'a' */
{
    s1_ptr c;
    register long length;
    register object temp_ap;
    register object_ptr ap, cp;

    /* a is a SEQ_PTR */
    length = a->length;
    c = NewS1(length);
    cp = c->base;
    ap = a->base;
    while (TRUE) {  // NOVALUE will be copied
        temp_ap = *(++ap);
        *(++cp) = temp_ap;
        if (!IS_ATOM_INT(temp_ap)) {
            if (temp_ap == NOVALUE)
                break;
            RefDS(temp_ap);
        }
    }
    DeRefSP(a);
    return c;
}

